home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1994 / MacHack 1994.toast / MacHack™94 / Talks & Papers / Timothy Knox / yerk 3.66 / System source / Ovl < prev    next >
Text File  |  1994-06-24  |  8KB  |  255 lines
  1. \ Module - overlay support for Yerk modules
  2. \ 11/19/84  CBD Version 1
  3. \  7/10/86  cdn rewrote reloc in code
  4. \  3/22/91    rfl prettied up (.mod)
  5. \  4/29/93    rfl    when modules are loaded, search for 'proc' and set with a5,a3
  6. \  5/01/93  rfl removed n>count since defined in nuc
  7. \  5/29/93    rfl    getPtrSize now takes relative pointer as input.
  8. \  5/31/93    rfl    added Mike Hore's trav words
  9. \  1/05/94    rfl    added keepMod...uses lock byte hi bit
  10. \  1/31/94    rfl    added ?pause to (.mods) and keeplocked for use within modules
  11. \  2/09/94    rfl    added purge! for sysinit. When program starts up, want
  12. \                  to purge all mods, even if locked (from the save)
  13.  
  14. Decimal
  15.  
  16. \ ( n -- 2^n )
  17. : 2**  1 swap << ;
  18.  
  19. \ the bitMap class is an array of bits - allocation is #bytes
  20. :CLASS bitMap  <Super Object  1 <indexed    \ for allocation only
  21.  
  22.     \ ( ind -- byte )  return the byte at ind
  23.     :M  BYTEAT:   ?range at1  ;M
  24.  
  25.     \ ( val ind -- )  store byte value at ind
  26.     :M  BYTETO:   ?range to1  ;M
  27.  
  28.     \ ( ind -- 1 OR 0 )  get bit #ind
  29.     :M  AT:  abs 8 /mod   byteAt: self  swap 2** And 0= 0=  ;M
  30.  
  31.     \ ( 1 OR 0 ind -- )  store bit #ind
  32.     :M  TO:  { val ind \ bit# -- }  ind  abs 8 /mod -> ind   -> bit#
  33.         ind byteAt: self  bit# 2** Or  ind byteTo: self ;M
  34.  
  35.     :M  SET:   1 swap To: self  ;M
  36.  
  37. ;CLASS
  38.  
  39. 0 Value Bits                \ will hold ptr to base of bitMap
  40. 'type BIN Constant binType    \ file type for overlays
  41. \ 6 constant parmsLen        \ 0:1=len, 2:5=original addr
  42.  
  43. \ ( addr len offset bits -- )  code version of module relocate
  44. Create reloc
  45.     $ 205f w,        \        move.l    (sp)+,a0    ; bits
  46.     $ 41f38804 ,    \        lea        4(a3,a0.l),a0
  47.     $ 201f w,        \        move.l    (sp)+,d0    ; offset (relocation factor)
  48.     $ 221f w,        \        move.l    (sp)+,d1    ; len
  49.     $ 225f w,        \        move.l    (sp)+,a1    ; base addr
  50.     $ 43f39800 ,    \        lea        0(a3,a1.l),a1
  51.  
  52.     $ 4284 w,        \        clr.l    d4            ; init module relative position
  53.     $ 143c0001 ,    \        move.b    #1,d2        ; init mask
  54.  
  55.     $ 1c02 w,        \ loop    move.b    d2,d6
  56.     $ cc3c0001 ,    \        and.b    #1,d6        ; time to get new byte?
  57.     $ 6702 w,        \        beq.s    test        ; no, still using same byte
  58.     $ 1618 w,        \        move.b    (a0)+,d3    ; get next "bits" byte
  59.  
  60.     $ 1c03 w,        \ test    move.b    d3,d6
  61.     $ cc02 w,        \        and.b    d2,d6        ; test this bit
  62.     $ 6704 w,        \        beq.s    nextb
  63.  
  64.     $ d1b14800 ,    \        add.l    d0,0(a1,d4.l)    ; add reloc factor
  65.  
  66.     $ e31a w,        \ nextb    rol.b    #1,d2        ; shift mask
  67.     $ 5484 w,        \        addq.l    #2,d4        ; increment offset into module
  68.     $ 5381 w,        \        subq.l    #1,d1
  69.     $ 66e4 w,        \        bne.s    loop        ; decrement len (bit map)
  70.  
  71.     next,
  72.  
  73. \ ( ovLen -- bitmapLen )  Find bitmap length for overlay
  74. : bitsLen  abs 16 /mod 2* swap IF 2+ THEN 8+ ;
  75.  
  76. \ leave name of binary file for module
  77. ( addr len -- addr1 len1 )
  78. : binName { addr len -- }
  79.     addr pad len cmove
  80.     " .BIN" pad len + swap cmove
  81.     pad len 4+ ;
  82.  
  83. \ ( nfa -- base )  load and relocate a binary module from it's data file
  84. : loadBin  { \ len bLen org base -- }
  85.     n>count binName name: fFcb
  86.     openReadOnly: fFcb ?error 138
  87.     size: fFcb 6 ( parmsLen ) -        \ find parms
  88.     moveto: fFcb drop
  89.     pad 6 ( parmsLen ) read: fFcb ?error 141
  90.     0 moveTo: fFcb drop
  91.     pad w@ -> len pad 2+ @ -> org    \ get parms
  92.     len ovBlock -> base                \ get block for module code
  93.     base len read: fFcb  ?error 141
  94.     len bitsLen -> bLen                \ length of bitmap in bytes
  95.     bLen 4+ ovBlock 4+ -> bits        \ heap for bitmap
  96.     bits 4- bLen read: fFcb ?error 141
  97.     close: fFcb  drop
  98.     bits 4- @ ' bitmap <> ?error 142    \ sentinel
  99.     base len base org - bits reloc        \ relocate the module
  100.     dispose> bits  base  ;
  101.  
  102. Handle mHndl
  103.  
  104. \ ( resID -- handle )  load and relocate a binary module from it's resource
  105. : loadBinR { \ len org -- }
  106.     GetRes CODE -dup 0= ?error 138
  107.     dup put: mHndl        \ leave copy of handle on the stack
  108.     ptr: mHndl size: mHndl + 6 -
  109.     dup w@ -> len  2+ @ -> org
  110.     ptr: mHndl len + 4+ -> bits
  111.     ptr: mHndl len over org - bits reloc
  112.     len setSize: mHndl    \ dump bitMap
  113. ;
  114.  
  115. : ?mod   @ modCode = ;
  116.  
  117. \ locking a module prevents the Yerk growZone routine from
  118. \ purging it while it is executing.
  119. \ ( cfa -- )  lock/unlock the module whose cfa is on stack
  120. : mUnlock   12 + dup c@ $ 80 and swap c! ;
  121. : mLock     12 + dup c@ $  1 or  swap c! ;
  122. : ?mlock    12 + c@ $ 1 and 1 = ;    \ true if module is locked
  123. : ?keep        12 + c@ $ 80 and $ 80 = ;
  124. : KeepLocked 1 swap 12 + @ $ ffffff and c! ;    \ use within module to keep
  125.                                                 \ it locked. In the case of an
  126.                                                 \ open window or the like.
  127.  
  128. : installMod { b -- } @word count sfind
  129.         IF drop cfa dup ?mod not ?error 147
  130.             12 + dup c@ b IF $ 80 or ELSE $ 7f and THEN swap c!
  131.         ELSE type# 172
  132.         THEN ;
  133.  
  134.  
  135. create getPtrSize popA0 $ d1cb w, $ a021 w, pushD0 next,
  136. create recoverHndl popA0 $ a128 w, pushA0 next,
  137. create geta3a5   ( -- a3 a5)  $ 2f0b w, $ 2f0d w,   next,
  138.  
  139. \ named input parm replace is true if handle,, false if ptr
  140. : fixProcMod { ptr replace \ len myString addr -- ptr }
  141.     replace IF ptr +base recoverHndl getHSize
  142.             ELSE ptr getPtrSize
  143.             THEN -> len
  144.     0 -> replace
  145.     heap> string -> myString new: myString
  146.     ptr len put: myString
  147.     start: mystring
  148.     BEGIN " proc" indexof: myString
  149.     WHILE ptr: myString + 4+ -> addr
  150.           getA3A5 addr ! addr 4+ !
  151.           where: myString 4+ moveto: myString
  152.           true -> replace
  153.     REPEAT
  154.     replace IF get: myString ptr swap cmove THEN
  155.     release: myString dispose> myString
  156.     ptr ;
  157.  
  158. \ mcfa structure to define a module. This will reside in the
  159. \ resident dictionary, being the link between resident words and
  160. \ words in the module.
  161.  
  162. 3 codeFields
  163.  
  164. \ ( addr -- )  Release the heap storage for the module
  165.     Do..  dup  c@ 1 and 0=    \ unlocked ?
  166.         IF  dup @ $ 7fffffff and 0 <>    \ unlocked and loaded?
  167.             IF dup 10 + w@
  168.                 IF dup 12 + @ $ a9a3 Trap    \ call ReleaseResource
  169.                 ELSE dup @ $ 7fffffff and killPtr THEN
  170.             THEN   dup @ $ 80000000 and swap !
  171.         ELSE  drop
  172.         THEN
  173.     ..End
  174.  
  175. \ ( offs addr -- )  execute the export vector at offset in module
  176.     Do..  dup 12 - >R        \ save the address of the mod's cfa
  177.         R execute            \ exec 0cfa to load the module
  178.         R mlock                \ lock the module while it executes
  179.         @ $ FFFFFF and >R R + @ execute    \ execute the import word
  180.         R> c@ IF R> drop    \ leave module locked?
  181.             ELSE R> mUnlock THEN
  182.     ..End
  183.  
  184. \ ( addr -- )  Load the module if not loaded
  185.     Do..  dup @ $ 7fffffff and 0=
  186.         IF dup 10 + w@ -dup    \ load module and update pointer to base
  187.             IF loadBinR 2dup swap 12 + ! >ptr true    \ resource based module
  188.             ELSE dup 12 - >name loadBin false         \ file based module    
  189.             THEN
  190.             fixProcMod                            \ search all :proc defs and fill w/a5,a3
  191.             over @ or swap !
  192.         ELSE drop
  193.         THEN
  194.     ..End
  195.  
  196. \ module def data consists of |^moduleBase|^lastImport|#imports|resID|mHandle|
  197. : modDef  Build 0, 0, 0 w, 0 w, 0, ..End
  198.  
  199. false value endTrav?    \ May be set from within a trav handler to terminate the trav
  200.  
  201. \ traverse the dictionary, applying passed-in proc to each cfa...start from nfa
  202. : (trav)  { theWord parm nfa -- } 
  203.     false -> endTrav? nfa
  204.     BEGIN  1 traverse align dup 4+ parm exec> theWord
  205.         @ dup 0= endTrav? or
  206.     UNTIL  drop ;
  207.  
  208. : trav latest (trav) ;
  209.  
  210. : travFrom ( nfa --) (trav) ;
  211.  
  212. \ handler to release selected modules
  213. : ?disp  { theCfa size -- }
  214.     theCfa ?mod  \ if this is a module
  215.     IF  free size <                \ if we still need space
  216.         IF   theCfa 8+ execute    \ 2cfa is Dispose>
  217.         THEN
  218.     THEN ;
  219.  
  220. \ Release will free all unlocked modules on a small Mac,
  221. \ and frees 150K bytes on a large Mac.
  222. : release   'c ?disp 150000 trav ;
  223.  
  224. \ release if unlocked - don't unlock
  225. : (purge)  { theCfa size -- }   theCfa ?mod
  226.     IF  theCfa 4+ 8+ dup c@ $ 81 and swap c!
  227.         theCfa size  ?disp
  228.     THEN ;
  229.  
  230. \ free all unlocked modules ( Forward reference in file: Base )
  231. :F purge  'c (purge) 100000000 trav ;F
  232.  
  233. \ use during startup (sysinit)...any module marked as locked should be cleared
  234. \  but keep install status
  235. : (purge!)  { theCfa size -- }   theCfa ?mod
  236.     IF  theCfa 4+ 8+ dup c@ $ 80 and swap c!
  237.         theCfa size ?disp
  238.     THEN ;
  239.  
  240. : purge! 'c (purge!) 100000000 trav ;
  241.  
  242. \ ( #bytes -- ) release modules until #bytes are available
  243. : need   freeblk . 'c ?disp swap  trav  ;
  244.  
  245. \ list existing modules and their load status
  246. : (.mod)  { theCfa size -- }  curs -curs theCfa  ?mod
  247.     IF  ?pause  cr theCfa >name id.  @xy swap drop 90 swap gotoxy
  248.         theCfa 12 + @ $ ffffff and .h
  249.         theCfa ?mLock IF type# 174 ( ***Locked***) THEN
  250.         theCfa ?keep IF type# 168 ( ***Keep***) THEN
  251.     THEN  -> curs ;
  252.  
  253. \ list modules and their load status
  254. : .mods   'c (.mod)  0 trav  ;
  255.